home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / calling.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  10.5 KB  |  327 lines
  1. ;;;; calling.scm --- Calling Conventions
  2. ;;;;
  3. ;;;;     Copyright (C) 1995, 1996, 1997, 2000, 2001, 2006 Free Software Foundation, Inc.
  4. ;;;; 
  5. ;;;; This library is free software; you can redistribute it and/or
  6. ;;;; modify it under the terms of the GNU Lesser General Public
  7. ;;;; License as published by the Free Software Foundation; either
  8. ;;;; version 2.1 of the License, or (at your option) any later version.
  9. ;;;; 
  10. ;;;; This library is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13. ;;;; Lesser General Public License for more details.
  14. ;;;; 
  15. ;;;; You should have received a copy of the GNU Lesser General Public
  16. ;;;; License along with this library; if not, write to the Free Software
  17. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18. ;;;; 
  19.  
  20. (define-module (ice-9 calling)
  21.   :export-syntax (with-excursion-function
  22.           with-getter-and-setter
  23.           with-getter
  24.           with-delegating-getter-and-setter
  25.           with-excursion-getter-and-setter
  26.           with-configuration-getter-and-setter
  27.           with-delegating-configuration-getter-and-setter
  28.           let-with-configuration-getter-and-setter))
  29.  
  30. ;;;;
  31. ;;;
  32. ;;; This file contains a number of macros that support 
  33. ;;; common calling conventions.
  34.  
  35. ;;;
  36. ;;; with-excursion-function <vars> proc
  37. ;;;  <vars> is an unevaluated list of names that are bound in the caller.
  38. ;;;  proc is a procedure, called:
  39. ;;;         (proc excursion)
  40. ;;;
  41. ;;;  excursion is a procedure isolates all changes to <vars>
  42. ;;;  in the dynamic scope of the call to proc.  In other words,
  43. ;;;  the values of <vars> are saved when proc is entered, and when
  44. ;;;  proc returns, those values are restored.   Values are also restored
  45. ;;;  entering and leaving the call to proc non-locally, such as using
  46. ;;;  call-with-current-continuation, error, or throw.
  47. ;;;
  48. (defmacro with-excursion-function (vars proc)
  49.   `(,proc ,(excursion-function-syntax vars)))
  50.  
  51.  
  52.  
  53. ;;; with-getter-and-setter <vars> proc
  54. ;;;  <vars> is an unevaluated list of names that are bound in the caller.
  55. ;;;  proc is a procedure, called:
  56. ;;;    (proc getter setter)
  57. ;;; 
  58. ;;;  getter and setter are procedures used to access
  59. ;;;  or modify <vars>.
  60. ;;; 
  61. ;;;  setter, called with keywords arguments, modifies the named
  62. ;;;  values.   If "foo" and "bar" are among <vars>, then:
  63. ;;; 
  64. ;;;    (setter :foo 1 :bar 2)
  65. ;;;    == (set! foo 1 bar 2)
  66. ;;; 
  67. ;;;  getter, called with just keywords, returns
  68. ;;;  a list of the corresponding values.  For example,
  69. ;;;  if "foo" and "bar" are among the <vars>, then
  70. ;;; 
  71. ;;;    (getter :foo :bar)
  72. ;;;    => (<value-of-foo> <value-of-bar>)
  73. ;;; 
  74. ;;;  getter, called with no arguments, returns a list of all accepted 
  75. ;;;  keywords and the corresponding values.  If "foo" and "bar" are
  76. ;;;  the *only* <vars>, then:
  77. ;;; 
  78. ;;;    (getter)
  79. ;;;    => (:foo <value-of-bar> :bar <value-of-foo>)
  80. ;;; 
  81. ;;;  The unusual calling sequence of a getter supports too handy
  82. ;;;  idioms:
  83. ;;; 
  84. ;;;    (apply setter (getter))        ;; save and restore
  85. ;;; 
  86. ;;;    (apply-to-args (getter :foo :bar)        ;; fetch and bind
  87. ;;;            (lambda (foo bar) ....))
  88. ;;; 
  89. ;;;     ;; [ "apply-to-args" is just like two-argument "apply" except that it 
  90. ;;;    ;;   takes its arguments in a different order.
  91. ;;; 
  92. ;;;
  93. (defmacro with-getter-and-setter (vars proc)
  94.   `(,proc ,@ (getter-and-setter-syntax vars)))
  95.  
  96. ;;; with-getter vars proc
  97. ;;;   A short-hand for a call to with-getter-and-setter.
  98. ;;;   The procedure is called:
  99. ;;;        (proc getter)
  100. ;;;
  101. (defmacro with-getter (vars proc)
  102.   `(,proc ,(car (getter-and-setter-syntax vars))))
  103.  
  104.  
  105. ;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
  106. ;;;   Compose getters and setters.
  107. ;;; 
  108. ;;;   <vars> is an unevaluated list of names that are bound in the caller.
  109. ;;;   
  110. ;;;   get-delegate is called by the new getter to extend the set of 
  111. ;;;    gettable variables beyond just <vars>
  112. ;;;   set-delegate is called by the new setter to extend the set of 
  113. ;;;    gettable variables beyond just <vars>
  114. ;;;
  115. ;;;   proc is a procedure that is called
  116. ;;;        (proc getter setter)
  117. ;;;
  118. (defmacro with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
  119.   `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))
  120.  
  121.  
  122. ;;; with-excursion-getter-and-setter <vars> proc
  123. ;;;   <vars> is an unevaluated list of names that are bound in the caller.
  124. ;;;   proc is called:
  125. ;;;
  126. ;;;        (proc excursion getter setter)
  127. ;;;
  128. ;;;   See also:
  129. ;;;    with-getter-and-setter
  130. ;;;    with-excursion-function
  131. ;;;
  132. (defmacro with-excursion-getter-and-setter (vars proc)
  133.   `(,proc  ,(excursion-function-syntax vars)
  134.       ,@ (getter-and-setter-syntax vars)))
  135.  
  136.  
  137. (define (excursion-function-syntax vars)
  138.   (let ((saved-value-names (map gensym vars))
  139.     (tmp-var-name (gensym "temp"))
  140.     (swap-fn-name (gensym "swap"))
  141.     (thunk-name (gensym "thunk")))
  142.     `(lambda (,thunk-name)
  143.        (letrec ((,tmp-var-name #f)
  144.         (,swap-fn-name
  145.          (lambda () ,@ (map (lambda (n sn) 
  146.                       `(begin (set! ,tmp-var-name ,n)
  147.                           (set! ,n ,sn)
  148.                           (set! ,sn ,tmp-var-name)))
  149.                     vars saved-value-names)))
  150.         ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars))
  151.      (dynamic-wind
  152.       ,swap-fn-name
  153.       ,thunk-name
  154.       ,swap-fn-name)))))
  155.  
  156.  
  157. (define (getter-and-setter-syntax vars)
  158.   (let ((args-name (gensym "args"))
  159.     (an-arg-name (gensym "an-arg"))
  160.     (new-val-name (gensym "new-value"))
  161.     (loop-name (gensym "loop"))
  162.     (kws (map symbol->keyword vars)))
  163.     (list `(lambda ,args-name
  164.          (let ,loop-name ((,args-name ,args-name))
  165.           (if (null? ,args-name)
  166.               ,(if (null? kws)
  167.                ''()
  168.                `(let ((all-vals (,loop-name ',kws)))
  169.                   (let ,loop-name ((vals all-vals)
  170.                            (kws ',kws))
  171.                    (if (null? vals)
  172.                        '()
  173.                        `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
  174.               (map (lambda (,an-arg-name)
  175.                  (case ,an-arg-name
  176.                    ,@ (append
  177.                    (map (lambda (kw v) `((,kw) ,v)) kws vars)
  178.                    `((else (throw 'bad-get-option ,an-arg-name))))))
  179.                ,args-name))))
  180.  
  181.       `(lambda ,args-name
  182.          (let ,loop-name ((,args-name ,args-name))
  183.           (or (null? ,args-name)
  184.               (null? (cdr ,args-name))
  185.               (let ((,an-arg-name (car ,args-name))
  186.                 (,new-val-name (cadr ,args-name)))
  187.             (case ,an-arg-name
  188.               ,@ (append
  189.                   (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
  190.                   `((else (throw 'bad-set-option ,an-arg-name)))))
  191.             (,loop-name (cddr ,args-name)))))))))
  192.  
  193. (define (delegating-getter-and-setter-syntax  vars get-delegate set-delegate)
  194.   (let ((args-name (gensym "args"))
  195.     (an-arg-name (gensym "an-arg"))
  196.     (new-val-name (gensym "new-value"))
  197.     (loop-name (gensym "loop"))
  198.     (kws (map symbol->keyword vars)))
  199.     (list `(lambda ,args-name
  200.          (let ,loop-name ((,args-name ,args-name))
  201.           (if (null? ,args-name)
  202.               (append!
  203.                ,(if (null? kws)
  204.                 ''()
  205.                 `(let ((all-vals (,loop-name ',kws)))
  206.                    (let ,loop-name ((vals all-vals)
  207.                         (kws ',kws))
  208.                     (if (null? vals)
  209.                     '()
  210.                     `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
  211.                (,get-delegate))
  212.               (map (lambda (,an-arg-name)
  213.                  (case ,an-arg-name
  214.                    ,@ (append
  215.                    (map (lambda (kw v) `((,kw) ,v)) kws vars)
  216.                    `((else (car (,get-delegate ,an-arg-name)))))))
  217.                ,args-name))))
  218.  
  219.       `(lambda ,args-name
  220.          (let ,loop-name ((,args-name ,args-name))
  221.           (or (null? ,args-name)
  222.               (null? (cdr ,args-name))
  223.               (let ((,an-arg-name (car ,args-name))
  224.                 (,new-val-name (cadr ,args-name)))
  225.             (case ,an-arg-name
  226.               ,@ (append
  227.                   (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
  228.                   `((else  (,set-delegate ,an-arg-name ,new-val-name)))))
  229.             (,loop-name (cddr ,args-name)))))))))
  230.  
  231.  
  232.  
  233.  
  234. ;;; with-configuration-getter-and-setter <vars-etc> proc
  235. ;;;
  236. ;;;  Create a getter and setter that can trigger arbitrary computation.
  237. ;;;
  238. ;;;  <vars-etc> is a list of variable specifiers, explained below.
  239. ;;;  proc is called:
  240. ;;;
  241. ;;;        (proc getter setter)
  242. ;;;
  243. ;;;   Each element of the <vars-etc> list is of the form:
  244. ;;;
  245. ;;;    (<var> getter-hook setter-hook)
  246. ;;;
  247. ;;;   Both hook elements are evaluated; the variable name is not.
  248. ;;;   Either hook may be #f or procedure.
  249. ;;;
  250. ;;;   A getter hook is a thunk that returns a value for the corresponding
  251. ;;;   variable.   If omitted (#f is passed), the binding of <var> is
  252. ;;;   returned.
  253. ;;;
  254. ;;;   A setter hook is a procedure of one argument that accepts a new value
  255. ;;;   for the corresponding variable.  If omitted, the binding of <var>
  256. ;;;   is simply set using set!.
  257. ;;;
  258. (defmacro with-configuration-getter-and-setter (vars-etc proc)
  259.   `((lambda (simpler-get simpler-set body-proc)
  260.       (with-delegating-getter-and-setter ()
  261.     simpler-get simpler-set body-proc))
  262.  
  263.     (lambda (kw)
  264.       (case kw
  265.     ,@(map (lambda (v) `((,(symbol->keyword (car v)))
  266.                  ,(cond
  267.                    ((cadr v)    => list)
  268.                    (else        `(list ,(car v))))))
  269.            vars-etc)))
  270.  
  271.     (lambda (kw new-val)
  272.       (case kw
  273.     ,@(map (lambda (v) `((,(symbol->keyword (car v)))
  274.                  ,(cond
  275.                    ((caddr v)    => (lambda (proc) `(,proc new-val)))
  276.                    (else        `(set! ,(car v) new-val)))))
  277.            vars-etc)))
  278.  
  279.        ,proc))
  280.  
  281. (defmacro with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
  282.   `((lambda (simpler-get simpler-set body-proc)
  283.       (with-delegating-getter-and-setter ()
  284.     simpler-get simpler-set body-proc))
  285.  
  286.     (lambda (kw)
  287.       (case kw
  288.     ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
  289.                       ,(cond
  290.                     ((cadr v)    => list)
  291.                     (else        `(list ,(car v))))))
  292.             vars-etc)
  293.            `((else (,delegate-get kw))))))
  294.  
  295.     (lambda (kw new-val)
  296.       (case kw
  297.     ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
  298.                       ,(cond
  299.                     ((caddr v)    => (lambda (proc) `(,proc new-val)))
  300.                     (else        `(set! ,(car v) new-val)))))
  301.             vars-etc)
  302.            `((else (,delegate-set kw new-val))))))
  303.  
  304.     ,proc))
  305.  
  306.  
  307. ;;; let-configuration-getter-and-setter <vars-etc> proc
  308. ;;;
  309. ;;;   This procedure is like with-configuration-getter-and-setter (q.v.)
  310. ;;;   except that each element of <vars-etc> is:
  311. ;;;
  312. ;;;        (<var> initial-value getter-hook setter-hook)
  313. ;;;
  314. ;;;   Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter
  315. ;;;   introduces bindings for the variables named in <vars-etc>.
  316. ;;;   It is short-hand for:
  317. ;;;
  318. ;;;        (let ((<var1> initial-value-1)
  319. ;;;              (<var2> initial-value-2)
  320. ;;;            ...)
  321. ;;;          (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
  322. ;;;
  323. (defmacro let-with-configuration-getter-and-setter (vars-etc proc)
  324.   `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
  325.      (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)
  326.                        ,proc)))
  327.